Progetto
Patrick Di Noto Marrella, 158007
2025-12-19
library(readr)
library(igraph)##
## Caricamento pacchetto: 'igraph'## I seguenti oggetti sono mascherati da 'package:stats':
##
## decompose, spectrum## Il seguente oggetto è mascherato da 'package:base':
##
## unionlibrary(ggraph)## Caricamento del pacchetto richiesto: ggplot2library(tidygraph)##
## Caricamento pacchetto: 'tidygraph'## Il seguente oggetto è mascherato da 'package:igraph':
##
## groups## Il seguente oggetto è mascherato da 'package:stats':
##
## filterlibrary(dplyr)##
## Caricamento pacchetto: 'dplyr'## I seguenti oggetti sono mascherati da 'package:igraph':
##
## as_data_frame, groups, union## I seguenti oggetti sono mascherati da 'package:stats':
##
## filter, lag## I seguenti oggetti sono mascherati da 'package:base':
##
## intersect, setdiff, setequal, unionlibrary(visNetwork)
library(htmlwidgets)
library(cluster)
library(factoextra)## Welcome! Want to learn more? See two factoextra-related books at https://goo.gl/ve3WBalibrary(ggplot2)DESCRIZIONE DATASET
airports.csv - Dataset degli aeroporti domestici USA contenente 358 aeroporti (riguardanti i primi 6 mesi da Gennaio a Giugno) con le seguenti informazioni:
airport_id: identificativo univoco dell’aeroporto name: nome ufficiale dell’aeroporto (es. “Hartsfield-Jackson Atlanta International”) city: città in cui si trova l’aeroporto state: stato USA (codice a 2 lettere)
flights.csv - Dataset dei voli commerciali domestici USA. Ogni riga rappresenta un volo effettivo con:
OriginAirportID: ID dell’aeroporto di origine DestAirportID: ID dell’aeroporto di destinazione Altri campi relativi al volo (giorno del mese, giorno della settimana, aereoporto origine, aereoporto destinazione, ritardi)
Il dataset permette di analizzare il traffico aereo reale contando il numero di voli per ogni rotta (coppia origine-destinazione)
airports = read.csv("c:/Users/Patrick/Desktop/Progetto_Advance/dataset/airports.csv")
flights = read.csv("c:/Users/Patrick/Desktop/Progetto_Advance/dataset/flights.csv")cat("Aeroporti:", nrow(airports), "\n")## Aeroporti: 365cat("Voli:", nrow(flights), "\n")## Voli: 2702218cat("Colonne flights:\n")## Colonne flights:print(colnames(flights))## [1] "DayofMonth" "DayOfWeek" "Carrier" "OriginAirportID"
## [5] "DestAirportID" "DepDelay" "ArrDelay"print(head(flights, 3))## DayofMonth DayOfWeek Carrier OriginAirportID DestAirportID DepDelay ArrDelay
## 1 19 5 DL 11433 13303 -3 1
## 2 19 5 DL 14869 12478 0 -8
## 3 19 5 DL 14057 14869 -4 -15Visualizzazione interattiva del grafo.
Preparazione di tutte le componenti.
Come prima cosa ho convertito in character la feature airport_id (integer) siccome la funzione graph_from_data_frame() crea nodi con essa.
Successivamente ho raggruppato i voli per coppia (origine-destinazione), ho contato quanti voli ci sono per ogni rotta e ordinati per numero di voli (decrescente) (non tengo conto dei diversi giorni in cui è avvenuto un volo). Al TERZO punto ho eliminato i voli i cui aereoporti di destinazione o origine non esistevano in airports.cvs(dati inconsistenti). Al QUARTO punto ho selezionato solo le rotte più trafficate, ossia le tratte con il numero maggiore di voli, per poi crearmi il grafo e, siccome alcuni campi potrebbero essere NA (valori mancanti) li sostituisco con valori di default. Ed infine vado a “preparare” gli archi e i nodi per essere usati nel grafo interattivo
Nel grafo non vengono visti tutti gli aereoporti per una questione di visualizzazione, ossia si tiene conto delle rotte più importanti e non di quelle secondarie.
airports$airport_id <- as.character(airports$airport_id)
# AGGREGA VOLI PER ROTTA
routes <- flights %>%
group_by(OriginAirportID, DestAirportID) %>%
summarise(n_flights = n(), .groups = "drop") %>%
arrange(desc(n_flights))
# FILTRA SOLO AEROPORTI CHE ESISTONO NEL DATASET
valid_airports <- airports$airport_id
routes_clean <- routes %>%
filter(as.character(OriginAirportID) %in% valid_airports &
as.character(DestAirportID) %in% valid_airports)
# Vedi la distribuzione, per capire quale valore mettere come filtro (75 quantile), catturo probabilmente ~75-80% del traffico con solo ~25% delle rotte
summary(routes_clean$n_flights)## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 1 359 706 1075 1478 9643quantile(routes_clean$n_flights, c(0.5, 0.75, 0.9, 0.95, 0.99))## 50% 75% 90% 95% 99%
## 706.00 1478.00 2383.00 3280.60 4869.44# Filtro per tenere conto solo delle rotte con più del 75 quantile
routes_filtered <- routes_clean %>%
filter(n_flights > 1478)
# CREA GRAFO
g <- graph_from_data_frame(
d = routes_filtered %>%
mutate(from = as.character(OriginAirportID),
to = as.character(DestAirportID)) %>%
select(from, to, n_flights),
directed = TRUE
)
# CREA LOOKUP per info aeroporti
airport_info <- airports %>%
select(airport_id, name, city, state) %>%
mutate(
city = ifelse(is.na(city), "Unknown", city),
name = ifelse(is.na(name), paste("Airport", airport_id), name),
state = ifelse(is.na(state), "N/A", state)
)
# CALCOLA DEGREE (numero di connessioni per ogni nodo)
degrees <- degree(g, mode = "all")
# PREPARA NODI
graph_airports <- data.frame(airport_id = V(g)$name, stringsAsFactors = FALSE) %>%
left_join(airport_info, by = "airport_id")
nodes_df <- data.frame(
airport_id = V(g)$name,
stringsAsFactors = FALSE
) %>%
left_join(airport_info, by = "airport_id") %>%
mutate(
city = ifelse(is.na(city), paste("ID", airport_id), city),
name = ifelse(is.na(name), paste("Airport", airport_id), name),
state = ifelse(is.na(state), "Unknown", state),
degree_val = degrees[airport_id]
) %>%
filter(!is.na(airport_id))
# 8. CREA NODI FINALE
nodes <- data.frame(
id = nodes_df$airport_id,
label = nodes_df$city,
title = paste0(
"<b>", nodes_df$name, "</b><br>",
"City: ", nodes_df$city, ", ", nodes_df$state, "<br>",
"Connections: ", nodes_df$degree_val
),
value = nodes_df$degree_val,
group = nodes_df$state,
stringsAsFactors = FALSE,
row.names = NULL
)
# PREPARA ARCHI
edges <- routes_filtered %>%
mutate(
from = as.character(OriginAirportID),
to = as.character(DestAirportID),
width = sqrt(n_flights) / 10, #lo spessore l'ho messo come radice quadrata del numero di voli / 10
title = paste(n_flights, "voli"),
arrows = "to"
) %>%
select(from, to, width, title, arrows)
# VISUALIZZAZIONE INTERATTIVA
vis_graph <- visNetwork(nodes, edges, width = "100%", height = "800px") %>%
#stile nodi
visNodes(
shape = "dot",
scaling = list(min = 15, max = 60),
font = list(size = 16, color = "black"),
borderWidth = 2,
color = list(
border = "darkblue",
background = "lightblue",
highlight = list(border = "red", background = "orange")
)
) %>%
#stile archi
visEdges(
arrows = list(to = list(enabled = TRUE, scaleFactor = 0.5)),
smooth = list(enabled = TRUE, type = "curvedCW", roundness = 0.2),
color = list(color = "rgba(100, 150, 200, 0.4)", highlight = "red")
) %>%
visOptions(
highlightNearest = list(enabled = TRUE, degree = 1, hover = TRUE), #: Al click evidenzia aeroporti vicini (distanza 1 = connessi direttamente)
nodesIdSelection = list(enabled = TRUE, main = "Seleziona Aeroporto"), #Menu a tendina per selezionare aeroporto specifico
selectedBy = list(variable = "group", main = "Seleziona per Stato") # Filtro per stato
) %>%
visPhysics(
solver = "forceAtlas2Based",
forceAtlas2Based = list(
gravitationalConstant = -65, #repulsione tra nodi
centralGravity = 0.01, #attrazione verso il centro
springLength = 400, #lunghezza archi
springConstant = 0.05 #rigidità
),
stabilization = list(iterations = 100)
) %>%
visInteraction(
navigationButtons = TRUE,
hover = TRUE,
zoomView = TRUE,
dragView = TRUE
) %>%
visLayout(randomSeed = 42) %>%
visLegend(width = 0.1, position = "right", main = "Stati")
# lo salvo come HTML
saveWidget(
vis_graph,
file = "grafo_rete_aerea.html",
selfcontained = TRUE
)
# Apro nel browser
browseURL("grafo_rete_aerea.html")mi calcolo la Betwweenness, ossia quante volte un nodo si trova lungo i percorsi più brevi che collegano altre coppie di nodi
g_full <- graph_from_data_frame(
d = routes_clean %>%
mutate(from = as.character(OriginAirportID),
to = as.character(DestAirportID)) %>%
select(from, to, n_flights),
directed = TRUE
)
# 2. CALCOLA BETWEENNESS (può richiedere 1-2 minuti)
betw <- betweenness(g_full, normalized = TRUE, directed = TRUE)
# 3. CREA DATAFRAME RISULTATI
betw_df <- data.frame(
airport_id = names(betw),
betweenness = betw,
stringsAsFactors = FALSE
) %>%
left_join(airports %>% select(airport_id, name, city, state),
by = "airport_id") %>%
arrange(desc(betweenness))
print(betw_df %>%
select(city, state, betweenness))## city state betweenness
## 1 Denver CO 2.982514e-02
## 2 Dallas/Fort Worth TX 2.948154e-02
## 3 Atlanta GA 2.903778e-02
## 4 Houston TX 2.882970e-02
## 5 Chicago IL 2.639653e-02
## 6 Phoenix AZ 2.560272e-02
## 7 Las Vegas NV 2.385872e-02
## 8 New York NY 2.067271e-02
## 9 Chicago IL 1.970142e-02
## 10 Minneapolis MN 1.753564e-02
## 11 Newark NJ 1.643106e-02
## 12 Washington DC 1.509168e-02
## 13 Los Angeles CA 1.497479e-02
## 14 San Francisco CA 1.475506e-02
## 15 Seattle WA 1.467154e-02
## 16 Salt Lake City UT 1.311661e-02
## 17 Boston MA 1.279736e-02
## 18 Charlotte NC 1.193652e-02
## 19 Detroit MI 1.009385e-02
## 20 Orlando FL 9.168958e-03
## 21 Baltimore MD 9.130550e-03
## 22 Portland OR 7.034522e-03
## 23 Philadelphia PA 6.983183e-03
## 24 Cleveland OH 6.730040e-03
## 25 San Diego CA 5.759237e-03
## 26 St. Louis MO 5.627054e-03
## 27 Houston TX 5.373028e-03
## 28 Tampa FL 4.801365e-03
## 29 Austin TX 4.797845e-03
## 30 Fort Lauderdale FL 4.729730e-03
## 31 New York NY 4.635647e-03
## 32 Kansas City MO 4.578214e-03
## 33 Washington DC 3.873587e-03
## 34 Miami FL 3.427756e-03
## 35 Oakland CA 3.107854e-03
## 36 Nashville TN 2.787046e-03
## 37 Sacramento CA 2.530445e-03
## 38 Cincinnati OH 2.453174e-03
## 39 New Orleans LA 2.382567e-03
## 40 Memphis TN 2.348981e-03
## 41 Albuquerque NM 1.814778e-03
## 42 San Jose CA 1.704128e-03
## 43 San Antonio TX 1.502025e-03
## 44 Fort Myers FL 1.308386e-03
## 45 Pittsburgh PA 1.245133e-03
## 46 Oklahoma City OK 1.066607e-03
## 47 Raleigh/Durham NC 9.667927e-04
## 48 Honolulu HI 8.053233e-04
## 49 Hartford CT 7.882430e-04
## 50 Indianapolis IN 6.715525e-04
## 51 Jacksonville FL 6.533106e-04
## 52 Anchorage AK 6.131727e-04
## 53 West Palm Beach/Palm Beach FL 5.187293e-04
## 54 Santa Ana CA 4.844996e-04
## 55 Milwaukee WI 4.322773e-04
## 56 San Juan PR 3.895276e-04
## 57 Columbus OH 3.525366e-04
## 58 Providence RI 3.166378e-04
## 59 Long Beach CA 3.110294e-04
## 60 Kahului HI 2.803501e-04
## 61 Dallas TX 2.698375e-04
## 62 Buffalo NY 2.141652e-04
## 63 Ontario CA 1.729738e-04
## 64 Louisville KY 1.626241e-04
## 65 Norfolk VA 1.457903e-04
## 66 Reno NV 1.152142e-04
## 67 Burbank CA 1.102115e-04
## 68 Omaha NE 1.043063e-04
## 69 Richmond VA 5.399311e-05
## 70 Tucson AZ 2.646757e-05Ottengo che Denver insieme a Dallas e Atlanta sono gli aereoporti con più alto Betwweenness. Che cosa significa? Denver è quasi al centro degli Stati Uniti, collega facilmente costa Est ↔︎ costa Ovest è l’ideale per voli di media durata, che sono i più redditizi riduce tempi, carburante e costi rispetto a rotte molto lunghe (naturale usarla come punto di scalo). DEN, ATL e DFW sono: molto grandi, con tante piste, pensati fin dall’inizio per gestire connessioni rapide
Denver, in particolare: - ha 6 piste (una delle più lunghe al mondo) - ha spazio per crescere senza limiti urbani intorno
Denver (e Atlanta, Dallas): ha costi operativi più bassi, meno congestione aerea rispetto a NYC o Los Angeles, meno ritardi cronici
Meteo relativamente affidabile
Rispetto a: Chicago (neve e vento), New York (tempeste + traffico), San Francisco (nebbia)
Visualizzo il grafo con gli aereoporti con betwweenness più alta
knitr::include_graphics("C:/Users/Patrick/Desktop/Progetto_Advance/immagine_Stati Uniti.png")
top_bW_airports <- head(betw_df, 70)$airport_id
routes_top_bw <- routes_clean %>%
filter(as.character(OriginAirportID) %in% top_bW_airports &
as.character(DestAirportID) %in% top_bW_airports) %>%
mutate(from = as.character(OriginAirportID),
to = as.character(DestAirportID))
g_top_bw <- graph_from_data_frame(
d = routes_top_bw %>% select(from, to, n_flights),
directed = TRUE
)
# Crea tabella con betweenness
node_df <- data.frame(
airport_id = V(g_top_bw)$name,
stringsAsFactors = FALSE
)
# Join con betweenness
node_df <- node_df %>%
left_join(betw_df %>% select(airport_id, betweenness, city, state),
by = "airport_id")
# AGGIUNGI al grafo
V(g_top_bw)$betweenness <- node_df$betweenness
V(g_top_bw)$city <- node_df$city
V(g_top_bw)$state <- node_df$state
set.seed(42)
ggraph(g_top_bw, layout = 'kk') +
geom_edge_link(
aes(alpha = n_flights, color = n_flights),
arrow = arrow(length = unit(1.5, 'mm'), type = "closed"),
end_cap = circle(2, 'mm')
) +
geom_node_point(
aes(size = betweenness, fill= betweenness),shape = 21,color = "white", stroke = 1.5, alpha = 0.9
) +
geom_node_text(
aes(label = city), size = 2.5, fontface = "bold",repel = TRUE
) +
scale_fill_viridis_c(
option = "plasma", name = "Betweenness", direction = -1
) +
scale_edge_color_gradient(
low = "#fee5d9", high = "#a50f15", name = "N. Voli"
) +
scale_size_continuous(range = c(2,8), guide = "none") +
scale_edge_width_continuous(range = c(0.2, 2), guide = "none") +
scale_edge_alpha_continuous(range = c(0.1, 1), guide = "none") +
theme_graph(background = "#f7f7f7") +
labs(
title = "Aeroporti per Betweenness Centrality",
subtitle = "Dimensione/Colore = Betweenness | Colore/Trasparenza archi = N. Voli"
) +
theme_void()
RAPPORTO IN_DEGREE - OUT_DEGREE
L’analisi del rapporto in-degree/out-degree rivela una rete fortemente simmetrica (balance ≈ 1 per tutti gli aeroporti), tipica dei network di trasporto aereo dove le rotte sono intrinsecamente bidirezionali. Questo conferma che non esistono aeroporti ‘destinazione pura’, ma tutti gli hub servono traffico in entrambe le direzioni. La Betweenness Centrality si è rivelata una metrica più discriminante per identificare gli hub critici come Denver, Dallas e Atlanta, che fungono da ponti necessari per molti viaggi transcontinentali.
# Calcola degree
degree_analysis <- data.frame(
airport_id = V(g_full)$name,
degree_in = degree(g_full, mode = "in"), # Rotte in arrivo
degree_out = degree(g_full, mode = "out"), # Rotte in partenza
stringsAsFactors = FALSE
) %>%
mutate(
degree_total = degree_in + degree_out,
# HUB hanno degree_in ≈ degree_out (bilanciato)
# DESTINAZIONE hanno degree_in > degree_out
balance = degree_in / degree_out,
type = case_when(
abs(balance - 1) < 0.2 ~ "Hub Bilanciato",
balance > 1.2 ~ "Destinazione (più arrivi)",
balance < 0.8 ~ "Origine (più partenze)"
)
) %>%
left_join(airports %>% select(airport_id, city, state), by = "airport_id") %>%
arrange(desc(balance))
print(degree_analysis)## airport_id degree_in degree_out degree_total balance type
## 1 14524 19 17 36 1.1176471 Hub Bilanciato
## 2 13830 14 13 27 1.0769231 Hub Bilanciato
## 3 13871 19 18 37 1.0555556 Hub Bilanciato
## 4 14730 23 22 45 1.0454545 Hub Bilanciato
## 5 12478 55 53 108 1.0377358 Hub Bilanciato
## 6 11066 28 27 55 1.0370370 Hub Bilanciato
## 7 14492 35 34 69 1.0294118 Hub Bilanciato
## 8 12953 39 38 77 1.0263158 Hub Bilanciato
## 9 11278 41 40 81 1.0250000 Hub Bilanciato
## 10 12892 54 54 108 1.0000000 Hub Bilanciato
## 11 12889 59 59 118 1.0000000 Hub Bilanciato
## 12 12173 21 21 42 1.0000000 Hub Bilanciato
## 13 10397 63 63 126 1.0000000 Hub Bilanciato
## 14 14107 59 59 118 1.0000000 Hub Bilanciato
## 15 14679 40 40 80 1.0000000 Hub Bilanciato
## 16 13204 50 50 100 1.0000000 Hub Bilanciato
## 17 11298 62 62 124 1.0000000 Hub Bilanciato
## 18 14831 22 22 44 1.0000000 Hub Bilanciato
## 19 10721 52 52 104 1.0000000 Hub Bilanciato
## 20 11292 62 62 124 1.0000000 Hub Bilanciato
## 21 14869 47 47 94 1.0000000 Hub Bilanciato
## 22 12191 35 35 70 1.0000000 Hub Bilanciato
## 23 11259 10 10 20 1.0000000 Hub Bilanciato
## 24 14747 49 49 98 1.0000000 Hub Bilanciato
## 25 11697 43 43 86 1.0000000 Hub Bilanciato
## 26 15304 43 43 86 1.0000000 Hub Bilanciato
## 27 10821 50 50 100 1.0000000 Hub Bilanciato
## 28 11433 53 53 106 1.0000000 Hub Bilanciato
## 29 13487 58 58 116 1.0000000 Hub Bilanciato
## 30 11057 55 55 110 1.0000000 Hub Bilanciato
## 31 10299 16 16 32 1.0000000 Hub Bilanciato
## 32 14893 25 25 50 1.0000000 Hub Bilanciato
## 33 13303 40 40 80 1.0000000 Hub Bilanciato
## 34 12266 60 60 120 1.0000000 Hub Bilanciato
## 35 13796 23 23 46 1.0000000 Hub Bilanciato
## 36 11042 47 47 94 1.0000000 Hub Bilanciato
## 37 12451 24 24 48 1.0000000 Hub Bilanciato
## 38 13232 52 52 104 1.0000000 Hub Bilanciato
## 39 13495 35 35 70 1.0000000 Hub Bilanciato
## 40 14683 28 28 56 1.0000000 Hub Bilanciato
## 41 14908 18 18 36 1.0000000 Hub Bilanciato
## 42 10693 42 42 84 1.0000000 Hub Bilanciato
## 43 11193 40 40 80 1.0000000 Hub Bilanciato
## 44 14057 37 37 74 1.0000000 Hub Bilanciato
## 45 10423 35 35 70 1.0000000 Hub Bilanciato
## 46 12264 51 51 102 1.0000000 Hub Bilanciato
## 47 14843 20 20 40 1.0000000 Hub Bilanciato
## 48 10140 24 24 48 1.0000000 Hub Bilanciato
## 49 10800 11 11 22 1.0000000 Hub Bilanciato
## 50 14635 27 27 54 1.0000000 Hub Bilanciato
## 51 13342 29 29 58 1.0000000 Hub Bilanciato
## 52 12339 29 29 58 1.0000000 Hub Bilanciato
## 53 13891 13 13 26 1.0000000 Hub Bilanciato
## 54 10792 19 19 38 1.0000000 Hub Bilanciato
## 55 14027 19 19 38 1.0000000 Hub Bilanciato
## 56 14570 14 14 28 1.0000000 Hub Bilanciato
## 57 15376 15 15 30 1.0000000 Hub Bilanciato
## 58 13931 19 19 38 1.0000000 Hub Bilanciato
## 59 14307 18 18 36 1.0000000 Hub Bilanciato
## 60 10529 25 25 50 1.0000000 Hub Bilanciato
## 61 13851 23 23 46 1.0000000 Hub Bilanciato
## 62 12954 13 13 26 1.0000000 Hub Bilanciato
## 63 13930 61 62 123 0.9838710 Hub Bilanciato
## 64 11618 56 57 113 0.9824561 Hub Bilanciato
## 65 14771 48 49 97 0.9795918 Hub Bilanciato
## 66 14100 47 48 95 0.9791667 Hub Bilanciato
## 67 15016 43 44 87 0.9772727 Hub Bilanciato
## 68 13198 39 40 79 0.9750000 Hub Bilanciato
## 69 14122 31 33 64 0.9393939 Hub Bilanciato
## 70 13244 37 40 77 0.9250000 Hub Bilanciato
## city state
## 1 Richmond VA
## 2 Kahului HI
## 3 Omaha NE
## 4 Louisville KY
## 5 New York NY
## 6 Columbus OH
## 7 Raleigh/Durham NC
## 8 New York NY
## 9 Washington DC
## 10 Los Angeles CA
## 11 Las Vegas NV
## 12 Honolulu HI
## 13 Atlanta GA
## 14 Phoenix AZ
## 15 San Diego CA
## 16 Orlando FL
## 17 Dallas/Fort Worth TX
## 18 San Jose CA
## 19 Boston MA
## 20 Denver CO
## 21 Salt Lake City UT
## 22 Houston TX
## 23 Dallas TX
## 24 Seattle WA
## 25 Fort Lauderdale FL
## 26 Tampa FL
## 27 Baltimore MD
## 28 Detroit MI
## 29 Minneapolis MN
## 30 Charlotte NC
## 31 Anchorage AK
## 32 Sacramento CA
## 33 Miami FL
## 34 Houston TX
## 35 Oakland CA
## 36 Cleveland OH
## 37 Jacksonville FL
## 38 Chicago IL
## 39 New Orleans LA
## 40 San Antonio TX
## 41 Santa Ana CA
## 42 Nashville TN
## 43 Cincinnati OH
## 44 Portland OR
## 45 Austin TX
## 46 Washington DC
## 47 San Juan PR
## 48 Albuquerque NM
## 49 Burbank CA
## 50 Fort Myers FL
## 51 Milwaukee WI
## 52 Indianapolis IN
## 53 Ontario CA
## 54 Buffalo NY
## 55 West Palm Beach/Palm Beach FL
## 56 Reno NV
## 57 Tucson AZ
## 58 Norfolk VA
## 59 Providence RI
## 60 Hartford CT
## 61 Oklahoma City OK
## 62 Long Beach CA
## 63 Chicago IL
## 64 Newark NJ
## 65 San Francisco CA
## 66 Philadelphia PA
## 67 St. Louis MO
## 68 Kansas City MO
## 69 Pittsburgh PA
## 70 Memphis TNAereoporti con maggior ritardo alla partenza e ritardi per rotta
Analizziamo i ritardi dei voli (DepDelay = ritardo alla partenza in minuti). Identifichiamo aeroporti e rotte più problematiche.
Ritardi per aeroporto di origine - Identifica quali aeroporti hanno più problemi di puntualità, ossia il ritardo alal partenza Ritardi per rotta - Mostra le tratte più problematiche, ossia quale tratta (origine → destinazione) ha i voli che partono più in ritardo. Metriche calcolate: Ritardo medio (minuti) Ritardo mediano Ritardo massimo che ha avuto un certo aereoporto alla partenza Percentuale voli con >15 minuti di ritardo (ad esempio chicago ha il 30% dei voli con ritardo più di 15min)
# RITARDI PER AEROPORTO DI ORIGINE
delay_by_origin <- flights %>%
filter(!is.na(DepDelay)) %>%
mutate(OriginAirportID = as.character(OriginAirportID)) %>%
group_by(OriginAirportID) %>%
summarise(
n_voli = n(),
ritardo_medio = mean(DepDelay),
ritardo_mediano = median(DepDelay),
ritardo_max = max(DepDelay),
perc_ritardo = sum(DepDelay > 15) / n() * 100, # % voli con >15min ritardo
.groups = "drop"
) %>%
left_join(airports %>% select(airport_id, city, state),
by = c("OriginAirportID" = "airport_id")) %>%
filter(n_voli >= 1000) %>% # Solo aeroporti con traffico significativo
arrange(desc(ritardo_medio))
print(delay_by_origin %>%
select(city, state, n_voli, ritardo_medio, perc_ritardo, ritardo_max) %>%
head(70))## # A tibble: 70 × 6
## city state n_voli ritardo_medio perc_ritardo ritardo_max
## <chr> <chr> <int> <dbl> <dbl> <int>
## 1 Chicago IL 49744 16.1 30.1 638
## 2 Chicago IL 127195 15.7 25.1 1094
## 3 Newark NJ 64313 14.6 23.3 878
## 4 Denver CO 97259 14.5 25.7 1144
## 5 Dallas/Fort Worth TX 104270 14.2 24.3 1145
## 6 Baltimore MD 51761 13.7 24.4 1172
## 7 New York NY 60351 13.5 21.8 1137
## 8 San Francisco CA 84276 13.5 22.5 1366
## 9 Houston TX 28963 13.1 25.9 1113
## 10 Washington DC 37429 13.0 20.5 736
## # ℹ 60 more rows# RITARDI PER ROTTA
delay_by_route <- flights %>%
filter(!is.na(DepDelay)) %>%
mutate(
OriginAirportID = as.character(OriginAirportID),
DestAirportID = as.character(DestAirportID)
) %>%
group_by(OriginAirportID, DestAirportID) %>%
summarise(
n_voli = n(),
ritardo_medio = mean(DepDelay),
perc_ritardo = sum(DepDelay > 15) / n() * 100,
.groups = "drop"
) %>%
filter(n_voli >= 100) %>% # Solo rotte frequenti
left_join(airports %>% select(airport_id, city, state),
by = c("OriginAirportID" = "airport_id")) %>%
rename(origin_city = city, origin_state = state) %>%
left_join(airports %>% select(airport_id, city, state),
by = c("DestAirportID" = "airport_id")) %>%
rename(dest_city = city, dest_state = state) %>%
arrange(desc(ritardo_medio))
print(delay_by_route %>%
mutate(rotta = paste(origin_city, "→", dest_city)) %>%
select(rotta, n_voli, ritardo_medio, perc_ritardo) %>%
head(70))## # A tibble: 70 × 4
## rotta n_voli ritardo_medio perc_ritardo
## <chr> <int> <dbl> <dbl>
## 1 Seattle → Miami 213 37.8 35.2
## 2 Chicago → Ontario 207 32.8 49.8
## 3 Fort Lauderdale → Richmond 199 32.6 39.2
## 4 Chicago → San Francisco 561 31.8 55.8
## 5 Norfolk → Minneapolis 140 31.8 43.6
## 6 Houston → New York 300 30.1 44.3
## 7 St. Louis → San Francisco 202 29.6 40.1
## 8 New York → Cincinnati 626 29.5 37.4
## 9 Dallas/Fort Worth → Kahului 204 29.3 32.8
## 10 Chicago → Jacksonville 151 29.1 38.4
## # ℹ 60 more rowsNotiamo che gli aeroporti di Chicago sono presenti 3 volte nella top 10 aereoporti con maggiori ritardi medi.
top_routes <- delay_by_route %>%
mutate(rotta = paste(origin_city, "→", dest_city)) %>%
arrange(desc(ritardo_medio)) %>%
head(10)
ggplot(top_routes, aes(x = reorder(rotta, ritardo_medio), y = ritardo_medio, fill = ritardo_medio)) +
geom_col() +
geom_text(aes(label = paste0(round(ritardo_medio, 1), " min\n(",
format(n_voli, big.mark = ","), " voli)")),
hjust = -0.1, size = 2.5) +
scale_fill_gradient(low = "yellow", high = "red", name = "Ritardo (min)") +
coord_flip() + # Barre orizzontali
ylim(0, max(top_routes$ritardo_medio) * 1.15) + # Spazio per etichette
labs(
title = "Top 10 Rotte con Maggiori Ritardi Medi",
subtitle = "Basato su ritardo medio alla partenza (6 mesi Gen-Giu)",
x = "Rotta",
y = "Ritardo Medio (minuti)"
) +
theme_minimal() +
theme(
axis.text.y = element_text(size = 8),
plot.title = element_text(face = "bold", size = 14)
)
Principali rotte aeree interne degli Stati Uniti (ponderate in base al numero di passeggeri)
knitr::include_graphics("C:/Users/Patrick/Desktop/Progetto_Advance/Principali rotte aeree stati uniti") ##
Traffico aereo
knitr::include_graphics("C:/Users/Patrick/Desktop/Progetto_Advance/traffico aereo.JPG")
Chicago con entrambi gli aereoporti sono i protagonisti (in negativo), ma perché? Perché Chicago combina meteo difficile (neve, vento e temporali), traffico enorme e spazio aereo congestionato Soprattutto O’Hare, nonostante i lavori recenti è nato negli anni 50, gate poco flessibili, rullaggi lunghissimi Lago Michigan, fenomeni come la neve da effetto lago e la nebbia, gli aerei tendono di passare sopra al lago, dove le condizioni sono più instabili Il 30% dei voli è in ritardo (con ritardo medio di 16 min)
# Grafico a barre top 20 aeroporti
top_delay_airports <- delay_by_origin %>% head(30)
ggplot(top_delay_airports, aes(x = reorder(city, -ritardo_medio), y = ritardo_medio, fill = perc_ritardo)) +
geom_col() +
scale_fill_gradient(low = "yellow", high = "red", name = "% Voli\nRitardo >15min") +
labs(
title = "Top 30 Aeroporti con Maggiori Ritardi",
subtitle = "Ritardo medio alla partenza (minuti)",
x = "Aeroporto",
y = "Ritardo Medio (minuti)"
) +
theme_minimal() +
theme(
plot.title = element_text(size = 14, face = "bold"),
axis.text.x = element_text(angle = 45, hjust = 1)
)
ANALISI TEMPO PERSO/GUADAGNATO IN VOLO
Calcoliamo la differenza tra ritardo alla partenza e ritardo all’arrivo per vedere se i piloti riescono a recuperare tempo in volo. Calcolo il tempo perso in volo come il DepDelay - ArrDelay (se è positivo vuol dire che ho guadagnato tempo, se è negativo vuol dire che ho perso tempo). Inoltre restituisco il risultato delle migliori tratte e delle peggiori tratte a livello di recupero di tempo
# Calcola tempo perso/guadagnato
flight_recovery <- flights %>%
filter(!is.na(DepDelay) & !is.na(ArrDelay)) %>%
mutate(
OriginAirportID = as.character(OriginAirportID),
DestAirportID = as.character(DestAirportID),
# Tempo recuperato = DepDelay - ArrDelay
# Positivo = recuperato tempo in volo
# Negativo = perso ulteriore tempo
time_recovery = DepDelay - ArrDelay
)
# Statistiche generali
cat("STATISTICHE RECUPERO TEMPO \n\n")## STATISTICHE RECUPERO TEMPOcat("Tempo medio recuperato in volo:", round(mean(flight_recovery$time_recovery), 2), "minuti\n")## Tempo medio recuperato in volo: 3.86 minuticat("Percentuale di voli che recuperano tempo (>0):",
round(sum(flight_recovery$time_recovery > 0) / nrow(flight_recovery) * 100, 1), "%\n")## Percentuale di voli che recuperano tempo (>0): 67.1 %cat("Percentuale di voli che perdono tempo (<0):",
round(sum(flight_recovery$time_recovery < 0) / nrow(flight_recovery) * 100, 1), "%\n")## Percentuale di voli che perdono tempo (<0): 28.6 %# Per rotta
recovery_by_route <- flight_recovery %>%
group_by(OriginAirportID, DestAirportID) %>%
summarise(
n_voli = n(),
recupero_medio = mean(time_recovery),
perc_di_recuperi = sum(time_recovery > 0) / n() * 100,
.groups = "drop"
) %>%
filter(n_voli >= 100) %>%
left_join(airports %>% select(airport_id, city, state),
by = c("OriginAirportID" = "airport_id")) %>%
rename(origin_city = city, origin_state = state) %>%
left_join(airports %>% select(airport_id, city, state),
by = c("DestAirportID" = "airport_id")) %>%
rename(dest_city = city, dest_state = state)
# Top rotte che recuperano di più
print(recovery_by_route %>%
mutate(rotta = paste(origin_city, "→", dest_city)) %>%
select(rotta, n_voli, recupero_medio, perc_di_recuperi) %>%
arrange(desc(recupero_medio)) %>%
head(70))## # A tibble: 70 × 4
## rotta n_voli recupero_medio perc_di_recuperi
## <chr> <int> <dbl> <dbl>
## 1 Orlando → San Diego 151 22.6 92.1
## 2 Washington → Honolulu 148 19.6 89.9
## 3 San Francisco → Anchorage 273 19.3 92.7
## 4 Jacksonville → Chicago 149 18.7 96.0
## 5 New York → San Antonio 214 18.3 81.3
## 6 Newark → Portland 365 17.2 81.9
## 7 Cleveland → Oklahoma City 174 17.2 86.8
## 8 Washington → Portland 213 16.8 82.6
## 9 Newark → Santa Ana 517 16.5 81.8
## 10 New York → Kansas City 214 16.2 73.8
## # ℹ 60 more rows# Top rotte che perdono più tempo
print(recovery_by_route %>%
mutate(rotta = paste(origin_city, "→", dest_city)) %>%
select(rotta, n_voli, recupero_medio, perc_di_recuperi) %>%
arrange(recupero_medio) %>%
head(70))## # A tibble: 70 × 4
## rotta n_voli recupero_medio perc_di_recuperi
## <chr> <int> <dbl> <dbl>
## 1 Cleveland → Philadelphia 125 -12.2 28
## 2 Hartford → Philadelphia 212 -7.32 41.0
## 3 Pittsburgh → Newark 142 -4.85 49.3
## 4 Hartford → San Juan 205 -4.75 39.5
## 5 New York → Philadelphia 412 -4.44 48.5
## 6 San Diego → Boston 592 -4.39 40.7
## 7 Charlotte → Austin 647 -4.20 36.0
## 8 Fort Myers → New York 325 -4.05 50.8
## 9 Seattle → Portland 1416 -3.76 24.1
## 10 Pittsburgh → Fort Lauderdale 317 -3.51 40.7
## # ℹ 60 more rowsVisualizzazione Recupero Tempo
Si possono notare ci sono molti minuti di recupero, soprattutto per quanto riguarda la tratta New York → Kansas, come mai? Questo beneficio non può essere attribuito a condizioni meteorologiche favorevoli o a rotte più brevi, ma piuttosto a fattori operativi specifici legati a questi aeroporti Le compagnie inseriscono margini extra negli orari ufficiali (per traffico e ritardi a New York). Se tutto va liscio, quel margine viene “recuperato” in volo. Meno congestione in arrivo Kansas ha meno traffico e attese rispetto a NYC, quindi l’atterraggio è spesso diretto.
Inoltre si ha una distribuzione quasi normale del tempo recuperato, con una media positiva, indicando che in generale i piloti riescono a compensare parte dei ritardi iniziali durante il volo. Per quanto riguarda i voli da Est a Ovest un fattore importante è il jetstream, che influenza in modo positivo il tempo di volo.
# Distribuzione del tempo recuperato
ggplot(flight_recovery, aes(x = time_recovery)) +
geom_histogram(bins = 100, fill = "steelblue", alpha = 0.7) +
geom_vline(xintercept = 0, color = "red", linetype = "dashed", size = 1) +
geom_vline(xintercept = mean(flight_recovery$time_recovery),
color = "darkgreen", linetype = "dashed", size = 1) +
annotate("text", x = mean(flight_recovery$time_recovery) + 5, y = Inf,
label = paste("Media:", round(mean(flight_recovery$time_recovery), 1), "min"),
vjust = 2, color = "darkgreen", fontface = "bold") +
xlim(-100, 100) +
labs(
title = "Distribuzione Tempo Recuperato/Perso in Volo",
subtitle = "Positivo = tempo recuperato | Negativo = tempo perso ulteriormente",
x = "Tempo Recuperato (minuti)",
y = "Numero di Voli"
) +
theme_minimal() +
theme(plot.title = element_text(size = 14, face = "bold"))## Warning: Using `size` aesthetic for lines was deprecated in ggplot2 3.4.0.
## ℹ Please use `linewidth` instead.
## This warning is displayed once every 8 hours.
## Call `lifecycle::last_lifecycle_warnings()` to see where this warning was
## generated.## Warning: Removed 1750 rows containing non-finite outside the scale range
## (`stat_bin()`).## Warning: Removed 2 rows containing missing values or values outside the scale range
## (`geom_bar()`).
# Top 30 rotte per recupero tempo
top_recovery <- recovery_by_route %>%
arrange(desc(recupero_medio)) %>%
head(30) %>%
mutate(rotta = paste(origin_city, "→", dest_city))
ggplot(top_recovery, aes(x = reorder(rotta, recupero_medio), y = recupero_medio, fill = perc_di_recuperi)) +
geom_col() +
coord_flip() +
scale_fill_gradient(low = "orange", high = "darkgreen", name = "% Voli che\nrecuperano") +
labs(
title = "Top 30 Rotte con Maggior Recupero Tempo in Volo",
subtitle = "Minuti medi recuperati durante il volo",
x = "Rotta",
y = "Tempo Medio Recuperato (minuti)"
) +
theme_minimal() +
theme(plot.title = element_text(size = 14, face = "bold"))
ANALISI TEMPORALE DEI RITARDI
Analizziamo come i ritardi variano in base al giorno della settimana e al giorno del mese, per identificare pattern temporali ricorrenti.
Ritardi per Giorno della Settimana
# ANALISI PER GIORNO DELLA SETTIMANA
# Mappa numeri a nomi giorni
day_names <- c("Lunedì", "Martedì", "Mercoledì", "Giovedì", "Venerdì", "Sabato", "Domenica")
delay_by_weekday <- flights %>%
filter(!is.na(DepDelay) & !is.na(DayOfWeek)) %>%
mutate(
DayName = factor(day_names[DayOfWeek], levels = day_names),
is_weekend = DayOfWeek %in% c(6, 7) # Sabato e Domenica
) %>%
group_by(DayOfWeek, DayName, is_weekend) %>%
summarise(
n_voli = n(),
ritardo_medio = mean(DepDelay),
ritardo_mediano = median(DepDelay),
sd_ritardo = sd(DepDelay),
perc_ritardo_15min = sum(DepDelay > 15) / n() * 100,
perc_ritardo_grave = sum(DepDelay > 30) / n() * 100,
.groups = "drop"
) %>%
arrange(DayOfWeek)
cat("STATISTICHE RITARDI PER GIORNO DELLA SETTIMANA\n\n")## STATISTICHE RITARDI PER GIORNO DELLA SETTIMANAprint(delay_by_weekday %>%
select(DayName, n_voli, ritardo_medio, perc_ritardo_15min, perc_ritardo_grave))## # A tibble: 7 × 5
## DayName n_voli ritardo_medio perc_ritardo_15min perc_ritardo_grave
## <fct> <int> <dbl> <dbl> <dbl>
## 1 Lunedì 407837 10.9 19.7 12.2
## 2 Martedì 397594 8.61 17.2 10.4
## 3 Mercoledì 403072 10.4 18.6 11.6
## 4 Giovedì 406563 13.6 23.2 14.8
## 5 Venerdì 396387 12.3 21.8 13.6
## 6 Sabato 318537 7.45 15.7 9.16
## 7 Domenica 372228 9.61 18.4 11.1# Identifica giorno peggiore e migliore
worst_day <- delay_by_weekday %>% filter(ritardo_medio == max(ritardo_medio))
best_day <- delay_by_weekday %>% filter(ritardo_medio == min(ritardo_medio))
cat("\n")cat("Giorno PEGGIORE:", worst_day$DayName, "- Ritardo medio:", round(worst_day$ritardo_medio, 2), "minuti\n")## Giorno PEGGIORE: 4 - Ritardo medio: 13.61 minuticat("Giorno MIGLIORE:", best_day$DayName, "- Ritardo medio:", round(best_day$ritardo_medio, 2), "minuti\n")## Giorno MIGLIORE: 6 - Ritardo medio: 7.45 minuti# Confronto Weekend vs Feriali
weekend_vs_weekday <- flights %>%
filter(!is.na(DepDelay) & !is.na(DayOfWeek)) %>%
mutate(periodo = ifelse(DayOfWeek %in% c(6, 7), "Weekend", "Giorni Feriali")) %>%
group_by(periodo) %>%
summarise(
n_voli = n(),
ritardo_medio = mean(DepDelay),
perc_ritardo_15min = sum(DepDelay > 15) / n() * 100,
.groups = "drop"
)
cat("\nCONFRONTO WEEKEND vs GIORNI FERIALI\n")##
## CONFRONTO WEEKEND vs GIORNI FERIALIprint(weekend_vs_weekday)## # A tibble: 2 × 4
## periodo n_voli ritardo_medio perc_ritardo_15min
## <chr> <int> <dbl> <dbl>
## 1 Giorni Feriali 2011453 11.2 20.1
## 2 Weekend 690765 8.62 17.2Visualizzazione Ritardi per Giorno Settimana
ANALISI RITARDI PER GIORNO DELLA SETTIMANA
L’analisi dei ritardi alla partenza per giorno della settimana rivela pattern operativi e di domanda distintamente diversi tra giorni feriali e weekend, basata su oltre 2.5 milioni di voli distribuiti nei 6 mesi da Gennaio a Giugno.
I giorni feriali (Lunedì-Venerdì) mostrano ritardi sistematicamente più elevati, con il venerdì che registra il picco settimanale di 13.6 minuti su 406,563 voli, seguito dal venerdì (12.3 minuti su 396,387 voli) e lunedì (10.3 minuti su 407,837 voli). Questo pattern riflette la natura del traffico business: il lunedì concentra i viaggi di inizio settimana con aeroporti che “ripartono” dopo il weekend, accumulando ritardi iniziali dovuti a riposizionamento di equipaggi e aeromobili. Il picco del venerdì è particolarmente significativo perché combina due fattori critici: (1) il massimo volume di traffico business della settimana, con professionisti che completano spostamenti urgenti prima del weekend, e (2) l’inizio del traffico leisure, con famiglie che partono anticipatamente per weekend lunghi, creando una sovrapposizione che congestiona gli aeroporti principali.
I giorni centrali della settimana (martedì-mercoledì-giovedì) mostrano ritardi intermedi (8.6-10.4 minuti), rappresentando il “regime stazionario” delle operazioni dove il traffico è prevalentemente business puro, senza picchi leisure, e le compagnie hanno ottimizzato crew e slot aeroportuali. Il martedì emerge come giorno più puntuale dei feriali (8.6 minuti su 397,594 voli), probabilmente perché beneficia del minor traffico post-lunedì e della pulizia operativa del weekend precedente.
Il weekend (sabato-domenica) presenta ritardi significativamente inferiori: il sabato è il giorno più puntuale della settimana con soli 7.4 minuti di ritardo medio su 318,537 voli, mentre la domenica registra 9.6 minuti su 372,228 voli. Il sabato beneficia di molteplici fattori favorevoli: (1) volume di traffico ridotto del ~22% rispetto ai giorni feriali (318k vs ~400k voli), (2) prevalenza di traffico leisure che è meno sensibile agli orari e tollera meglio riprogrammazioni, (3) minor congestione degli slot aeroportuali con aeroporti business-oriented (LaGuardia, Reagan National) che operano sotto capacità, e (4) equipaggi più riposati dopo il picco del venerdì.
La domenica mostra un lieve aumento dei ritardi rispetto al sabato (+2.2 minuti) nonostante un volume di traffico simile. Questo incremento è attribuibile al traffico di rientro del weekend: mentre il sabato vede partenze distribuite tutto il giorno, la domenica concentra i rientri nelle fasce pomeridiane/serali (14:00-21:00), creando picchi di congestione temporanea negli hub principali. Inoltre, la domenica pomeriggio inizia il riposizionamento strategico di aeromobili ed equipaggi in preparazione del lunedì mattina business, aggiungendo complessità operativa.
Differenziale weekend vs feriali: La differenza media di ~4.5 minuti tra giorni feriali (media 11.1 min) e weekend (media 8.3 min) quantifica l’impatto del volume di traffico e della tipologia di passeggero sulla puntualità. Questo gap evidenzia come la congestione sistemica (troppi voli simultanei in slot limitati) contribuisca più ai ritardi rispetto a problematiche tecniche o meteorologiche, che sarebbero distribuite uniformemente su tutti i giorni della settimana.
Implicazioni operative: Il pattern suggerisce che compagnie aeree e aeroporti potrebbero ottimizzare le tariffe per incentivare spostamenti di traffico dal venerdì (sovraccarico) al martedì/mercoledì (sottoutilizzato), migliorando la puntualità complessiva senza investimenti infrastrutturali. Inoltre, il dato weekend dimostra che la rete aerea USA ha capacità latente significativa: se operasse sempre ai livelli di congestione del sabato, i ritardi medi calerebbero del ~33%.
# Grafico a barre per giorno della settimana
ggplot(delay_by_weekday, aes(x = DayName, y = ritardo_medio, fill = is_weekend)) +
geom_col(alpha = 0.8) +
geom_text(aes(label = paste0(round(ritardo_medio, 1), " min\n(",
format(n_voli, big.mark = ","), " voli)")),
vjust = -0.5, fontface = "bold", size = 3.5) +
scale_fill_manual(values = c("FALSE" = "steelblue", "TRUE" = "coral"),
labels = c("Giorni Feriali", "Weekend"),
name = "") +
ylim(0,18) +
labs(
title = "Ritardo Medio alla Partenza per Giorno della Settimana",
subtitle = "Evidenziati weekend vs giorni feriali",
x = "Giorno della Settimana",
y = "Ritardo Medio (minuti)"
) +
theme_minimal() +
theme(
plot.title = element_text(size = 14, face = "bold"),
axis.text.x = element_text(angle = 45, hjust = 1, size = 11),
legend.position = "top"
)
Ritardi per Giorno del Mese
# ANALISI PER GIORNO DEL MESE
delay_by_monthday <- flights %>%
filter(!is.na(DepDelay) & !is.na(DayofMonth)) %>%
mutate(
periodo_mese = case_when(
DayofMonth <= 10 ~ "Inizio Mese (1-10)",
DayofMonth <= 20 ~ "Metà Mese (11-20)",
TRUE ~ "Fine Mese (21-31)"
)
) %>%
group_by(DayofMonth, periodo_mese) %>%
summarise(
n_voli = n(),
ritardo_medio = mean(DepDelay),
ritardo_mediano = median(DepDelay),
perc_ritardo_15min = sum(DepDelay > 15) / n() * 100,
perc_ritardo_grave = sum(DepDelay > 30) / n() * 100,
.groups = "drop"
) %>%
arrange(DayofMonth)
cat("STATISTICHE RITARDI PER GIORNO DEL MESE\n\n")## STATISTICHE RITARDI PER GIORNO DEL MESEprint(delay_by_monthday %>%
select(DayofMonth, n_voli, ritardo_medio, perc_ritardo_15min))## # A tibble: 31 × 4
## DayofMonth n_voli ritardo_medio perc_ritardo_15min
## <int> <int> <dbl> <dbl>
## 1 1 84636 8.87 17.6
## 2 2 89760 10.9 19.2
## 3 3 90172 9.70 18.6
## 4 4 84758 6.34 14.4
## 5 5 86426 6.25 14.5
## 6 6 87702 7.09 15.7
## 7 7 88011 10.1 18.3
## 8 8 89019 10.7 19.2
## 9 9 91412 11.4 21.0
## 10 10 90025 16.3 24.5
## # ℹ 21 more rows# Identifica giorni migliori e peggiori
worst_days <- delay_by_monthday %>% arrange(desc(ritardo_medio)) %>% head(5)
best_days <- delay_by_monthday %>% arrange(ritardo_medio) %>% head(5)
cat("\nTop 5 GIORNI PEGGIORI del mese:\n")##
## Top 5 GIORNI PEGGIORI del mese:print(worst_days %>% select(DayofMonth, ritardo_medio, perc_ritardo_15min))## # A tibble: 5 × 3
## DayofMonth ritardo_medio perc_ritardo_15min
## <int> <dbl> <dbl>
## 1 10 16.3 24.5
## 2 18 14.1 22.9
## 3 19 13.4 22.5
## 4 13 13.1 22.2
## 5 22 13.0 22.9cat("\nTop 5 GIORNI MIGLIORI del mese:\n")##
## Top 5 GIORNI MIGLIORI del mese:print(best_days %>% select(DayofMonth, ritardo_medio, perc_ritardo_15min))## # A tibble: 5 × 3
## DayofMonth ritardo_medio perc_ritardo_15min
## <int> <dbl> <dbl>
## 1 5 6.25 14.5
## 2 4 6.34 14.4
## 3 6 7.09 15.7
## 4 31 7.65 16.8
## 5 15 7.83 17.3# Confronto Inizio vs Metà vs Fine Mese
delay_by_period <- flights %>%
filter(!is.na(DepDelay) & !is.na(DayofMonth)) %>%
mutate(
periodo_mese = case_when(
DayofMonth <= 10 ~ "Inizio Mese (1-10)",
DayofMonth <= 20 ~ "Metà Mese (11-20)",
TRUE ~ "Fine Mese (21-31)"
)
) %>%
group_by(periodo_mese) %>%
summarise(
n_voli = n(),
ritardo_medio = mean(DepDelay),
perc_ritardo_15min = sum(DepDelay > 15) / n() * 100,
perc_ritardo_grave = sum(DepDelay > 30) / n() * 100,
.groups = "drop"
)
cat("\nCONFRONTO PER PERIODO DEL MESE\n")##
## CONFRONTO PER PERIODO DEL MESEprint(delay_by_period)## # A tibble: 3 × 5
## periodo_mese n_voli ritardo_medio perc_ritardo_15min perc_ritardo_grave
## <chr> <int> <dbl> <dbl> <dbl>
## 1 Fine Mese (21-31) 932976 10.4 19.4 11.9
## 2 Inizio Mese (1-10) 881921 9.81 18.3 11.4
## 3 Metà Mese (11-20) 887321 11.3 20.3 12.5Visualizzazione Ritardi per Giorno del Mese
INTERPRETAZIONE PATTERN MENSILE DEI RITARDI
L’andamento dei ritardi nel corso del mese rivela un pattern ciclico significativo che riflette le dinamiche operative del traffico aereo. L’inizio mese (giorni 1-10) mostra ritardi relativamente contenuti (media ~10 minuti), probabilmente grazie al “reset” operativo dopo la fine del mese precedente: gli equipaggi sono riposati, la manutenzione programmata è completata, e gli slot aeroportuali si riorganizzano. Il picco drammatico al giorno 10 (~16 minuti) coincide spesso con il primo weekend completo post-festività o eventi, quando il traffico leisure aumenta improvvisamente sovrapponendosi a quello business.
La metà mese (giorni 11-20) presenta l’andamento più stabile (~12-13 minuti), rappresentando il periodo di “regime” dove le operazioni sono standardizzate. È interessante notare che i giorni 15-17 mostrano un calo anomalo (~8 minuti), probabilmente correlato alla minore domanda infrasettimanale dopo il weekend di metà mese, quando molti viaggiatori business completano i loro spostamenti e il traffico leisure non è ancora ripartito.
La fine mese (giorni 21-31) evidenzia un trend decrescente marcato (da ~13 a ~7.5 minuti). Questo fenomeno può essere spiegato da molteplici fattori: (1) accumulo di personale riserva - verso fine mese le compagnie hanno equipaggi extra disponibili per coprire le assenze accumulate; (2) maggiore esperienza operativa - dopo 3 settimane di operazioni, le crew hanno ottimizzato le procedure; (3) riduzione traffico business - gli ultimi giorni del mese vedono meno viaggi d’affari urgenti; (4) pressione sui KPI - compagnie aeree e aeroporti “spingono” per chiudere il mese con metriche di puntualità migliori, fondamentali per i report mensili.
Il crollo finale al giorno 31 (~7.5 minuti, tra i migliori del mese) suggerisce anche un possibile bias statistico: molti voli programmati per il 31 slittano contabilmente al 1° del mese successivo in caso di ritardo, “pulendo” artificialmente i dati dell’ultimo giorno. Complessivamente, questo pattern evidenzia come la puntualità aerea non sia casuale ma fortemente influenzata da cicli operativi, gestione delle risorse umane e dinamiche commerciali prevedibili.
# Grafico a linee per giorno del mese
ggplot(delay_by_monthday, aes(x = DayofMonth, y = ritardo_medio)) +
geom_line(color = "darkblue", size = 1) +
geom_point(aes(color = periodo_mese), size = 3, alpha = 0.8) +
geom_smooth(method = "loess", se = TRUE, color = "red",
linetype = "dashed", alpha = 0.2) +
geom_hline(yintercept = mean(delay_by_monthday$ritardo_medio),
linetype = "dashed", color = "gray50", alpha = 0.7) +
scale_color_brewer(palette = "Set1", name = "Periodo Mese") +
scale_x_continuous(breaks = seq(1, 31, 2)) +
labs(
title = "Ritardo Medio alla Partenza per Giorno del Mese",
subtitle = "Linea rossa = trend | Linea grigia = media mensile",
x = "Giorno del Mese",
y = "Ritardo Medio (minuti)"
) +
theme_minimal() +
theme(
plot.title = element_text(size = 14, face = "bold"),
legend.position = "top"
)## `geom_smooth()` using formula = 'y ~ x'
delay_by_period_plot <- flights %>%
filter(!is.na(DepDelay) & !is.na(DayofMonth)) %>%
mutate(
periodo_mese = factor(
case_when(
DayofMonth <= 10 ~ "Inizio (1-10)",
DayofMonth <= 20 ~ "Metà (11-20)",
TRUE ~ "Fine (21-31)"
),
levels = c("Inizio (1-10)", "Metà (11-20)", "Fine (21-31)")
)
)Heatmap: Giorno Settimana vs Giorno Mese
Nella seguente heatmap possiamo notare che effettivamente i ritardi variano molto in base al giorno del mese e al giorno della settimana, con i giorni centrali del mese che tendono ad avere ritardi maggiori rispetto all’inizio e alla fine del mese. Inoltre, i fine settimana (sabato e domenica) mostrano generalmente ritardi inferiori rispetto ai giorni feriali. Questo pattern suggerisce che la gestione del traffico aereo e le operazioni aeroportuali possono essere influenzate da fattori temporali specifici, come la domanda di viaggio e la congestione degli aeroporti in determinati periodi del mese e della settimana.
# HEATMAP COMBINATA GIORNO SETTIMANA x GIORNO MESE
heatmap_data <- flights %>%
filter(!is.na(DepDelay) & !is.na(DayOfWeek) & !is.na(DayofMonth)) %>%
group_by(DayOfWeek, DayofMonth) %>%
summarise(
n_voli = n(),
ritardo_medio = mean(DepDelay),
perc_ritardo = sum(DepDelay > 15) / n() * 100,
.groups = "drop"
) %>%
mutate(DayName = factor(day_names[DayOfWeek], levels = day_names))
# Heatmap ritardo medio
ggplot(heatmap_data, aes(x = DayofMonth, y = DayName, fill = ritardo_medio)) +
geom_tile(color = "white", size = 0.5) +
geom_text(aes(label = round(ritardo_medio, 0)),
color = "white", size = 2.5, fontface = "bold") +
scale_fill_gradient2(
low = "darkgreen", mid = "yellow", high = "darkred",
midpoint = mean(heatmap_data$ritardo_medio),
name = "Ritardo Medio\n(minuti)"
) +
scale_x_continuous(breaks = seq(1, 31, 2)) +
labs(
title = "Heatmap Ritardi: Giorno Settimana vs Giorno Mese",
subtitle = "Verde = meno ritardi | Rosso = più ritardi",
x = "Giorno del Mese",
y = "Giorno della Settimana"
) +
theme_minimal() +
theme(
plot.title = element_text(size = 14, face = "bold"),
axis.text.y = element_text(size = 11, face = "bold"),
legend.position = "right"
)
cluster sui ritardi
Con il metodo silhouette vado a capire il numero ottimale di cluster, così da poter eseguire il k-means in modo più efficace.
# CLUSTERING AEROPORTI PER PATTERN DI RITARDI
# Prepara features per clustering
cluster_data <- flights %>%
filter(!is.na(DepDelay) & !is.na(ArrDelay)) %>%
mutate(OriginAirportID = as.character(OriginAirportID)) %>%
group_by(OriginAirportID) %>%
summarise(
n_voli = n(),
# Metriche ritardo
ritardo_medio_dep = mean(DepDelay),
ritardo_medio_arr = mean(ArrDelay),
sd_ritardo_dep = sd(DepDelay),
sd_ritardo_arr = sd(ArrDelay),
# Percentili
ritardo_p75_dep = quantile(DepDelay, 0.75),
ritardo_p95_dep = quantile(DepDelay, 0.95),
# Pattern temporali
perc_ritardo_grave = sum(DepDelay > 30) / n() * 100,
perc_anticipo = sum(DepDelay < -5) / n() * 100,
# Recupero tempo
recupero_medio = mean(DepDelay - ArrDelay),
.groups = "drop"
) %>%
filter(n_voli >= 1000) %>% # Solo aeroporti significativi
left_join(airports %>% select(airport_id, city, state),
by = c("OriginAirportID" = "airport_id"))
# Prepara matrice per clustering (rimuovi ID e nomi)
cluster_matrix <- cluster_data %>%
select(-OriginAirportID, -city, -state, -n_voli) %>%
scale() # Standardizza
# USA città + codice aeroporto per evitare duplicati (ho avuto il problema su CHicago e New York)
rownames(cluster_matrix) <- paste0(cluster_data$city, " (", cluster_data$OriginAirportID, ")")
# Determina numero ottimale di cluster
fviz_nbclust(cluster_matrix, kmeans, method = "silhouette") +
labs(title = "Metodo Silhouette - Numero Ottimale Cluster")
# Eseguo K-means con numero ottimale
set.seed(42)
k <- 3
km_result <- kmeans(cluster_matrix, centers = k, nstart = 25)
# Aggiungi cluster ai dati
cluster_data$cluster <- km_result$cluster# Estrai coordinate PCA
pca_coords <- prcomp(cluster_matrix)$x[, 1:2]
pca_df <- data.frame(
city = cluster_data$city,
airport_id = cluster_data$OriginAirportID,
PC1 = pca_coords[, 1],
PC2 = pca_coords[, 2],
cluster = as.factor(km_result$cluster)
)
ggplot(pca_df, aes(x = PC1, y = PC2, color = cluster, label = city)) +
geom_point(size = 3, alpha = 0.7) +
geom_text(vjust = -0.5, size = 2.5, fontface = "bold") + # Nomi aeroporti
stat_ellipse(aes(group = cluster), type = "norm", level = 0.68) +
scale_color_brewer(palette = "Set2") +
labs(
title = "Clustering Aeroporti per Pattern Ritardi",
subtitle = "Principal Component Analysis (PCA)",
x = "PC1",
y = "PC2",
color = "Cluster"
) +
theme_minimal() +
theme(
plot.title = element_text(face = "bold", size = 14),
legend.position = "right"
)## Warning: The following aesthetics were dropped during statistical transformation: label.
## ℹ This can happen when ggplot fails to infer the correct grouping structure in
## the data.
## ℹ Did you forget to specify a `group` aesthetic or to convert a numerical
## variable into a factor?
INTERPRETAZIONE DEI 3 CLUSTER L’analisi di clustering ha identificato tre gruppi distinti di aeroporti con pattern di ritardi significativamente diversi:
VERDE CLUSTER 1 - “Aeroporti Mediamente Efficienti” (34 aeroporti) Include aeroporti come Albuquerque, Austin, Nashville, Boston, Buffalo, New York, Washington, Philadelphia e Miami.
Questo cluster presenta ritardi moderati (9.41 minuti alla partenza, 6.19 all’arrivo) con una buona percentuale di voli in anticipo (22.66%). Gli aeroporti di questo gruppo mostrano una gestione operativa bilanciata, con l’11.16% di ritardi gravi. Si tratta principalmente di hub della Costa Est e città medie che riescono a mantenere un equilibrio tra volume di traffico ed efficienza operativa.
ARANCIO CLUSTER 2 - “Aeroporti Più Puntuali” (21 aeroporti) Comprende Anchorage, Hartford, Burbank, Honolulu, Long Beach, Portland, San Francisco e Phoenix.
Questo cluster si distingue per i ritardi più bassi tra tutti i gruppi (6.50 minuti alla partenza, 3.30 all’arrivo) e la minore variabilità (31.13). Con solo l’8.48% di ritardi gravi e il 22.15% di voli in anticipo, rappresenta gli aeroporti più efficienti in termini di puntualità. Si tratta principalmente di aeroporti secondari, regionali o della Costa Ovest che beneficiano di una minore congestione rispetto ai mega-hub nazionali.
BLU CLUSTER 3 - “Mega-Hub Congestionati” (15 aeroporti) Include i principali hub nazionali: Atlanta, Dallas, Denver, Chicago, Houston e Fort Worth, oltre a Baltimore.
Questo cluster presenta i ritardi più elevati (13.27 minuti alla partenza, 8.62 all’arrivo) e la percentuale più alta di ritardi gravi (14.06%). Significativamente, solo il 10.81% dei voli parte in anticipo, circa la metà rispetto agli altri cluster. Nonostante ciò, questi aeroporti mostrano il miglior recupero di tempo in volo (4.65 minuti), suggerendo che i piloti compensano attivamente i ritardi a terra accelerando durante il volo. Questi hub sono essenziali per la connettività nazionale ma soffrono di congestione sistemica dovuta all’altissimo volume di traffico gestito.
I risultati evidenziano un chiaro trade-off tra connettività e puntualità. I mega-hub (Cluster 3) offrono più collegamenti ma con ritardi significativamente maggiori, mentre aeroporti secondari (Cluster 2) garantiscono migliore puntualità a scapito di minore connettività diretta.
# STATISTICHE DETTAGLIATE PER CLUSTER
cluster_stats <- cluster_data %>%
group_by(cluster) %>%
summarise(
n_aeroporti = n(),
# Ritardi medi
ritardo_medio_partenza = round(mean(ritardo_medio_dep), 2),
ritardo_medio_arrivo = round(mean(ritardo_medio_arr), 2),
# Variabilità
variabilita_ritardi = round(mean(sd_ritardo_dep), 2),
# Percentuali
perc_ritardi_gravi = round(mean(perc_ritardo_grave), 2),
perc_anticipo = round(mean(perc_anticipo), 2),
# Recupero tempo
recupero_medio = round(mean(recupero_medio), 2),)
print(cluster_stats)## # A tibble: 3 × 8
## cluster n_aeroporti ritardo_medio_partenza ritardo_medio_arrivo
## <int> <int> <dbl> <dbl>
## 1 1 34 9.41 6.19
## 2 2 21 6.5 3.3
## 3 3 15 13.3 8.62
## # ℹ 4 more variables: variabilita_ritardi <dbl>, perc_ritardi_gravi <dbl>,
## # perc_anticipo <dbl>, recupero_medio <dbl># Visualizza aeroporti per cluster
for(i in 1:k) {
cluster_airports <- cluster_data %>%
filter(cluster == i) %>%
arrange(desc(n_voli)) %>%
select(city, state, ritardo_medio_dep, perc_ritardo_grave, recupero_medio)
print(cluster_airports)
}## # A tibble: 34 × 5
## city state ritardo_medio_dep perc_ritardo_grave recupero_medio
## <chr> <chr> <dbl> <dbl> <dbl>
## 1 Los Angeles CA 9.54 10.9 3.34
## 2 Charlotte NC 9.47 11.2 1.00
## 3 Boston MA 9.50 11.6 3.96
## 4 Detroit MI 9.26 10.9 3.57
## 5 Orlando FL 10.9 12.1 3.95
## 6 New York NY 11.1 13.2 4.87
## 7 Philadelphia PA 10.5 12.2 3.79
## 8 Washington DC 8.23 10.2 2.44
## 9 Miami FL 10.1 12.2 3.24
## 10 Tampa FL 8.79 10.1 3.42
## # ℹ 24 more rows
## # A tibble: 21 × 5
## city state ritardo_medio_dep perc_ritardo_grave recupero_medio
## <chr> <chr> <dbl> <dbl> <dbl>
## 1 Phoenix AZ 8.20 9.82 2.91
## 2 Minneapolis MN 7.41 9.40 4.02
## 3 Seattle WA 6.70 7.76 2.39
## 4 Salt Lake City UT 5.36 7.64 3.38
## 5 San Diego CA 8.43 10.1 3.22
## 6 Portland OR 5.90 7.89 3.07
## 7 New Orleans LA 8.08 10.0 3.44
## 8 Oakland CA 8.28 9.30 3.52
## 9 Sacramento CA 7.69 8.78 2.96
## 10 San Jose CA 6.96 8.67 2.17
## # ℹ 11 more rows
## # A tibble: 15 × 5
## city state ritardo_medio_dep perc_ritardo_grave recupero_medio
## <chr> <chr> <dbl> <dbl> <dbl>
## 1 Atlanta GA 10.9 11.6 6.12
## 2 Chicago IL 15.7 17.1 4.09
## 3 Dallas/Fort Worth TX 14.2 15.2 3.96
## 4 Denver CO 14.5 15.0 3.02
## 5 San Francisco CA 13.5 15.5 4.78
## 6 Las Vegas NV 11.9 12.7 3.78
## 7 Houston TX 11.2 12.4 6.16
## 8 Newark NJ 14.6 16.1 7.26
## 9 New York NY 13.5 14.9 7.03
## 10 Baltimore MD 13.7 13.8 4.06
## 11 Chicago IL 16.1 15.7 4.32
## 12 Washington DC 13.0 13.6 4.60
## 13 St. Louis MO 11.3 12.4 4.01
## 14 Houston TX 13.1 13.4 4.07
## 15 Dallas TX 11.8 11.6 2.45# Confronto visivo tra cluster
library(tidyr)##
## Caricamento pacchetto: 'tidyr'## Il seguente oggetto è mascherato da 'package:igraph':
##
## crossinglibrary(ggplot2)
cluster_comparison <- cluster_data %>%
select(cluster, city, ritardo_medio_dep, sd_ritardo_dep,
perc_ritardo_grave, recupero_medio) %>%
pivot_longer(cols = c(ritardo_medio_dep, sd_ritardo_dep,
perc_ritardo_grave, recupero_medio),
names_to = "metrica",
values_to = "valore")
ggplot(cluster_comparison, aes(x = as.factor(cluster), y = valore, fill = as.factor(cluster))) +
geom_boxplot() +
facet_wrap(~metrica, scales = "free_y", ncol = 2) +
scale_fill_brewer(palette = "Set2", name = "Cluster") +
labs(
title = "Confronto Caratteristiche tra Cluster",
x = "Cluster",
y = "Valore"
) +
theme_minimal() +
theme(
plot.title = element_text(face = "bold", size = 14),
strip.text = element_text(face = "bold")
)
- perc_ritardo_grave (% Ritardi Gravi)
Percentuale di voli con ritardo >30 minuti alla partenza, indica la frequenza di disservizi gravi
recupero_medio (Tempo Recuperato in Volo) differenza tra ritardo partenza e ritardo arrivo Formula: DepDelay - ArrDelay Positivo = tempo guadagnato in volo
ritardo_medio_dep (Ritardo Medio Partenza) Media semplice dei minuti di ritardo alla partenza Include voli in anticipo (negativi) e in ritardo (positivi)
sd_ritardo_dep (Deviazione Standard Ritardo Partenza)
Variabilità/dispersione dei ritardi intorno alla media Quanto i ritardi sono prevedibili vs caotici
ANALISI DI ROBUSTEZZA DELLA RETE AEREA
Analizziamo quanto è robusta la rete aerea rimuovendo progressivamente gli aeroporti più “critici” secondo diverse metriche di centralità.
Vado a scrivermii la funzione Percolate che abbiamo visto in classe. Inoltre implemento la funzione di betweenness adattiva che ricalcola la betweenness dopo ogni rimozione di nodo (METODO PIu’ EFFICACE MA LENTO)
# Funzione percolate standard
percolate <- function(g, size, d) {
giant <- vector()
# dimensione iniziale della giant component
c <- components(g)
giant[1] <- max(c$csize)
# trova nodi vitali
names(d) <- 1:length(d)
d <- sort(d, decreasing = TRUE)
vital <- as.integer(names(d[1:size]))
# calcola dimensione giant component dopo rimozione incrementale
for (i in 1:size) {
c <- components(delete_vertices(g, vital[1:i]))
giant[i+1] <- max(c$csize)
}
return(giant)
}
# Funzione per attacco adattivo betweenness (ricalcola ogni volta)
adaptive_betweenness_attack <- function(g, k) {
gc_sizes <- numeric(k + 1)
gc_sizes[1] <- max(components(g)$csize)
g2 <- g
for (i in 1:k) {
# 1. Calcola betweenness aggiornata
b <- betweenness(g2)
# 2. Rimuovi il nodo più centrale
highest <- which.max(b)
g2 <- delete_vertices(g2, highest)
# 3. Registra dimensione componente gigante
gc_sizes[i + 1] <- ifelse(vcount(g2) > 0,
max(components(g2)$csize),
0)
}
return(gc_sizes)
}Eseguo gli attachi per grado, pagerank, betweenness e power centrality
# ESEGUI ATTACCHI
size = vcount(g_full) - 1
#degree
deg <- degree(g_full, mode = "all")
#pagerank
pr <- page_rank(g_full)$vector
#betwweenness
bet <- betweenness(g_full, normalized = TRUE, directed = TRUE)
#potenza
pow <- power_centrality(g_full, exponent = 1)
# Funzione helper per stampare top nodi
print_top_nodes <- function(metric, metric_name, n = 35) {
# Ordina per metrica decrescente
sorted_nodes <- sort(metric, decreasing = TRUE)
# Prendi top n
top_ids <- names(sorted_nodes)[1:n]
# Crea dataframe con info
top_df <- data.frame(
rank = 1:n,
airport_id = top_ids,
metric_value = sorted_nodes[1:n],
stringsAsFactors = FALSE
) %>%
left_join(airports %>% select(airport_id, city, state),
by = "airport_id")
cat(paste0("\n", metric_name, ":\n"))
print(top_df %>%
mutate(metric_value = round(metric_value, 3)) %>%
select(rank, city, state, metric_value))
}
print_top_nodes(deg, "DEGREE")##
## DEGREE:
## rank city state metric_value
## 1 1 Atlanta GA 126
## 2 2 Dallas/Fort Worth TX 124
## 3 3 Denver CO 124
## 4 4 Chicago IL 123
## 5 5 Houston TX 120
## 6 6 Las Vegas NV 118
## 7 7 Phoenix AZ 118
## 8 8 Minneapolis MN 116
## 9 9 Newark NJ 113
## 10 10 Charlotte NC 110
## 11 11 Los Angeles CA 108
## 12 12 New York NY 108
## 13 13 Detroit MI 106
## 14 14 Boston MA 104
## 15 15 Chicago IL 104
## 16 16 Washington DC 102
## 17 17 Orlando FL 100
## 18 18 Baltimore MD 100
## 19 19 Seattle WA 98
## 20 20 San Francisco CA 97
## 21 21 Philadelphia PA 95
## 22 22 Salt Lake City UT 94
## 23 23 Cleveland OH 94
## 24 24 St. Louis MO 87
## 25 25 Fort Lauderdale FL 86
## 26 26 Tampa FL 86
## 27 27 Nashville TN 84
## 28 28 Washington DC 81
## 29 29 San Diego CA 80
## 30 30 Miami FL 80
## 31 31 Cincinnati OH 80
## 32 32 Kansas City MO 79
## 33 33 New York NY 77
## 34 34 Memphis TN 77
## 35 35 Portland OR 74print_top_nodes(pr, "PAGERANK")##
## PAGERANK:
## rank city state metric_value
## 1 1 Atlanta GA 0.024
## 2 2 Denver CO 0.024
## 3 3 Dallas/Fort Worth TX 0.024
## 4 4 Chicago IL 0.023
## 5 5 Houston TX 0.023
## 6 6 Phoenix AZ 0.023
## 7 7 Las Vegas NV 0.023
## 8 8 Minneapolis MN 0.022
## 9 9 Newark NJ 0.021
## 10 10 New York NY 0.021
## 11 11 Charlotte NC 0.021
## 12 12 Los Angeles CA 0.021
## 13 13 Chicago IL 0.020
## 14 14 Detroit MI 0.020
## 15 15 Boston MA 0.020
## 16 16 Washington DC 0.020
## 17 17 Seattle WA 0.019
## 18 18 Orlando FL 0.019
## 19 19 Baltimore MD 0.019
## 20 20 San Francisco CA 0.019
## 21 21 Salt Lake City UT 0.018
## 22 22 Cleveland OH 0.018
## 23 23 Philadelphia PA 0.018
## 24 24 St. Louis MO 0.017
## 25 25 Fort Lauderdale FL 0.016
## 26 26 Tampa FL 0.016
## 27 27 Nashville TN 0.016
## 28 28 San Diego CA 0.016
## 29 29 Washington DC 0.016
## 30 30 Miami FL 0.015
## 31 31 Cincinnati OH 0.015
## 32 32 New York NY 0.015
## 33 33 Kansas City MO 0.015
## 34 34 Portland OR 0.015
## 35 35 Memphis TN 0.014print_top_nodes(bet, "BETWEENNESS")##
## BETWEENNESS:
## rank city state metric_value
## 1 1 Denver CO 0.030
## 2 2 Dallas/Fort Worth TX 0.029
## 3 3 Atlanta GA 0.029
## 4 4 Houston TX 0.029
## 5 5 Chicago IL 0.026
## 6 6 Phoenix AZ 0.026
## 7 7 Las Vegas NV 0.024
## 8 8 New York NY 0.021
## 9 9 Chicago IL 0.020
## 10 10 Minneapolis MN 0.018
## 11 11 Newark NJ 0.016
## 12 12 Washington DC 0.015
## 13 13 Los Angeles CA 0.015
## 14 14 San Francisco CA 0.015
## 15 15 Seattle WA 0.015
## 16 16 Salt Lake City UT 0.013
## 17 17 Boston MA 0.013
## 18 18 Charlotte NC 0.012
## 19 19 Detroit MI 0.010
## 20 20 Orlando FL 0.009
## 21 21 Baltimore MD 0.009
## 22 22 Portland OR 0.007
## 23 23 Philadelphia PA 0.007
## 24 24 Cleveland OH 0.007
## 25 25 San Diego CA 0.006
## 26 26 St. Louis MO 0.006
## 27 27 Houston TX 0.005
## 28 28 Tampa FL 0.005
## 29 29 Austin TX 0.005
## 30 30 Fort Lauderdale FL 0.005
## 31 31 New York NY 0.005
## 32 32 Kansas City MO 0.005
## 33 33 Washington DC 0.004
## 34 34 Miami FL 0.003
## 35 35 Oakland CA 0.003print_top_nodes(pow, "POWER CENTRALITY")# STAMPA ORDINE DI RIMOZIONE PER OGNI METRICA##
## POWER CENTRALITY:
## rank city state metric_value
## 1 1 Long Beach CA 0.100
## 2 2 Orlando FL -0.035
## 3 3 Washington DC -0.057
## 4 4 Burbank CA -0.188
## 5 5 Anchorage AK -0.229
## 6 6 St. Louis MO -0.235
## 7 7 Fort Myers FL -0.245
## 8 8 Columbus OH -0.250
## 9 9 Santa Ana CA -0.273
## 10 10 Raleigh/Durham NC -0.276
## 11 11 Omaha NE -0.300
## 12 12 Houston TX -0.300
## 13 13 Miami FL -0.312
## 14 14 Hartford CT -0.323
## 15 15 Oakland CA -0.460
## 16 16 San Juan PR -0.475
## 17 17 Seattle WA -0.476
## 18 18 Albuquerque NM -0.506
## 19 19 Buffalo NY -0.538
## 20 20 Newark NJ -0.539
## 21 21 Atlanta GA -0.562
## 22 22 Boston MA -0.576
## 23 23 Norfolk VA -0.612
## 24 24 Tucson AZ -0.632
## 25 25 Milwaukee WI -0.645
## 26 26 Phoenix AZ -0.714
## 27 27 Las Vegas NV -0.803
## 28 28 New York NY -0.804
## 29 29 Baltimore MD -0.819
## 30 30 Minneapolis MN -0.833
## 31 31 New York NY -0.836
## 32 32 Dallas TX -0.846
## 33 33 San Francisco CA -0.862
## 34 34 Kahului HI -0.886
## 35 35 Denver CO -0.911attack_deg <- percolate(g_full, size, d = deg)
attack_pr <- percolate(g_full, size, d = pr)
attack_bet <- percolate(g_full, size, d = bet)attack_power <- percolate(g_full, size, d = 1/pow)
attack_dyn <- adaptive_betweenness_attack(g_full, size)# VISUALIZZAZIONE
plot(0:size, attack_deg, type = "l", col = 1, lwd = 2,
xlab = "Numero di nodi rimossi",
ylab = "Dimensione componente connessa più grande",
main = "Robustezza della Rete Aerea agli Attacchi Mirati",
ylim = c(0, vcount(g_full)))
lines(0:size, attack_pr, col = 2, lwd = 2)
lines(0:size, attack_bet, col = 3, lwd = 2)
lines(0:size, attack_dyn, col = 4, lwd = 2)
lines(0:size, attack_power, col = 5, lwd = 2)
# Linea di riferimento (metà nodi)
abline(h = vcount(g_full)/2, lty = 2, col = "gray", lwd = 1.5)
abline(v = size, lty = 2, col = "gray", lwd = 1.5)
legend("topright",
legend = c("Degree", "PageRank", "Betweenness (statico)",
"Betweenness (adattivo)",
"Power Centrality"),
lty = 1, col = 1:5, lwd = 2, cex = 0.8,
bg = "white")
grid()
Comportamento Iniziale (0-20 nodi rimossi)
Tutte le strategie mostrano curve quasi sovrapposte nelle prime rimozioni. Questo fenomeno rivela tre caratteristiche fondamentali della rete aerea USA:
Convergenza delle metriche sui mega-hub: Gli aeroporti con i valori più alti di Degree, PageRank, Betweenness sono sostanzialmente gli stessi - Denver, Atlanta, Dallas, Chicago. Indipendentemente dalla metrica utilizzata, le prime rimozioni colpiscono questi hub principali.
Robustezza intrinseca della rete: Anche rimuovendo i principali hub (primi 15-20 nodi), la componente gigante rimane quasi intatta grazie all’alta ridondanza del sistema. Esistono percorsi alternativi attraverso altri hub secondari che mantengono la connettività della rete.
Struttura scale-free: Tipica delle reti di trasporto aereo, questa topologia è estremamente resistente agli attacchi mirati iniziali. La rete “assorbe” la perdita dei primi hub senza frammentarsi.
Divergenza delle Strategie (20-50 nodi rimossi)
Dopo aver superato la soglia critica (~25-30 nodi rimossi, circa 35-40% della rete), le curve iniziano a divergere:
Betweenness Adattivo - La strategia più efficace - Questa curva scende più rapidamente perché ricalcola la betweenness ad ogni passo - Identifica dinamicamente quali aeroporti sono diventati i nuovi “ponti critici” dopo ogni rimozione - È l’attacco teoricamente ottimale per frammentare una rete - Il crollo accelerato indica che colpisce sempre i collegamenti strategici rimanenti
Betweenness Statico - Efficace ma sub-ottimale - Usa la betweenness calcolata all’inizio e non si aggiorna - Rimane efficace perché gli aeroporti con alta betweenness iniziale restano importanti - Tuttavia, dopo ~30 rimozioni, la topologia è cambiata e alcuni nodi “vitali” inizialmente non lo sono più - Per questo motivo è meno efficace del metodo adattivo
Power Centrality - Approccio bilanciato - Combina grado e connessioni di qualità - Curiosamente, rimuove aeroporti completamente diversi rispetto a Betweenness/Degree all’inizio - Nonostante ciò, l’impatto è identico - questo conferma l’alta ridondanza della rete - Rimuovere l’hub X o l’hub Y ha lo stesso effetto finché ci sono percorsi alternativi - Diventa meno efficace dopo la soglia critica perché non identifica i ponti cruciali
PageRank e Degree - Meno efficaci - Queste metriche si concentrano sulla “popolarità” o sul numero di connessioni - Non considerano il ruolo strutturale dei nodi come ponti - Possono rimuovere hub ben connessi che però hanno molti percorsi alternativi - Sono più lente nel frammentare la rete perché non colpiscono i colli di bottiglia
Conclusione
L’analisi conferma che la rete aerea USA è una rete scale-free robusta-ma-fragile: - Robusta a guasti casuali o attacchi limitati (alta ridondanza iniziale) - Fragile se si supera una soglia critica di ~30-35% degli hub compromessi - I mega-hub (Denver, Atlanta, Dallas) sono insostituibili - rimuoverli sistematicamente con strategie adattive porta al rapido collasso della connettività nazionale